home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Toolbox classes / QD < prev    next >
Encoding:
Text File  |  1995-11-24  |  4.3 KB  |  228 lines  |  [TEXT/MSET]
  1. \ QuickDraw support.
  2.  
  3.     0    constant    SRCCOPY        \ equates for drawing modes
  4.     1    constant    SRCOR
  5.     2    constant    SRCXOR
  6.  
  7. \ Random - returns a random number 0 - N. N is limited to an Int
  8. \  value. Larger than that means that numbers will be poorly distributed.
  9.  
  10. : RANDOM    \ ( n -- rand*N )
  11.     word0  call Random  word0 swap mod  ;
  12.  
  13. \ Line drawing:
  14.  
  15. : HIDEPEN        call HidePen  ;
  16. : SHOWPEN        call ShowPen  ;
  17.  
  18. \ ( horiz vert -- )
  19.  
  20. : MOVEPEN    pack  call Move    ;
  21. : MOVETO    pack  call MoveTo    ;
  22. : LINETO    pack  call LineTo    ;
  23. : LINE        pack  call Line    ;
  24.  
  25. : DEL    \ Draws a downward-pointing arrow to the right of and 
  26.         \ below the current pen position.
  27.     11 0 line    -1 1 movePen
  28.     -9 0 line     1 1 movePen
  29.      7 0 line    -1 1 movePen
  30.     -5 0 line     1 1 movePen
  31.      3 0 line    -1 1 movePen
  32.     -1 0 line  ;
  33.  
  34.  
  35. \        ============= Patterns ===============
  36.  
  37.  
  38. :class    PATTERN  super{ resource }
  39.  
  40. record {  ptr    CURR  }
  41.  
  42. :m GETNEW:    \ ( pat# -- ptr )
  43.     'type PAT#  swap  set: self  getnew: super
  44.     3 <<  ptr: self  2+  +  put: curr  ;m
  45.  
  46. :m GET:        get: curr  ;m
  47.  
  48. ;class
  49.  
  50.  
  51. objPtr    TMPPTN     class_is  pattern
  52.  
  53. pattern    SYSPATTN
  54.  
  55. : SYSPAT    \ ( pat# -- ^pat-obj )
  56.     0 getnew: sysPattn
  57.     sysPattn  ;
  58.  
  59.  
  60.  
  61. :class  POINT    super{ object }
  62. record
  63. {    int    Y        \ Vertical coordinate
  64.     int    X        \ Horizontal  coordinate
  65. }
  66.  
  67. :m GETX:    get: x  ;m
  68. :m GETY:    get: y  ;m
  69.  
  70. :m PUTX:    put: x  ;m
  71. :m PUTY:    put: y  ;m
  72.  
  73. :m SHIFTX:    +: x  ;m
  74. :m SHIFTY:    +: y  ;m
  75. :m SHIFT:    +: y  +: x  ;m
  76.  
  77. :m GET:        get: X  get: Y   ;m
  78. :m PUT:        put: Y  put: X   ;m
  79.  
  80. :m INT:        inline{ obj @}  ^base @  ;m
  81.  
  82. :m ->:        inline{ @ obj !}  chksame  @  ^base !  ;m
  83.  
  84. ;class
  85.  
  86.  
  87. :class  RECT  super{ object }
  88.  
  89. record
  90. {    point    TOPL
  91.     point    BOTR
  92. }
  93.  
  94. :m GET:        get: topl   get: botr  ;m    ( -- l t r b )
  95. :m PUT:        put: botr   put: topl  ;m    ( l t r b -- )
  96.  
  97. :m GETTOP:    get:  topl  ;m        ( -- l t )
  98. :m TOPINT:    int:  topl  ;m
  99. :m GETTOPX:    getx: topl  ;m
  100. :m GETTOPY:    gety: topl  ;m
  101. :m PUTTOP:    put:  topl  ;m
  102. :m PUTTOPX:    putx: topl  ;m
  103. :m PUTTOPY:    puty: topl  ;m
  104.  
  105. :m GETBOT:    get:  botr  ;m
  106. :m BOTINT:    int:  botr  ;m
  107. :m GETBOTX:    getx: botr  ;m
  108. :m GETBOTY:    gety: botr  ;m
  109. :m PUTBOT:    put:  botr  ;m
  110. :m PUTBOTX:    putx: botr  ;m
  111. :m PUTBOTY:    puty: botr  ;m
  112.  
  113. :m SIZE:        \ ( -- width height )  Calculates rect's size
  114.     getx: botr  getx: topl  -
  115.     gety: botr  gety: topl  -  ;m
  116.  
  117. :m SETSIZE:    ( w h -- )
  118.     getTopY: self  +  putBotY: self
  119.     getTopX: self  +  putBotX: self  ;m
  120.  
  121. :m GETCENTER:  { \ x y -- x y }
  122.     size: self  2/  -> y  2/ -> x
  123.     getx: topl  x +  gety: topl y +  ;m
  124.     
  125. :m INSET:    \ ( dx dy -- )  Makes rect smaller by dx dy.
  126.     pack  ^base  swap  call insetRect  ;m
  127.  
  128. :m SHIFT:  { dx dy -- }
  129.     dx dy or  0EXIT
  130.     dx dy  shift: topL  dx dy  shift: botR  ;m
  131.  
  132. :m OFFSET:    shift: self  ;m        \ Old name - for compatibility
  133.  
  134. :m STRETCH:  { dx dy -- }  dx dy  shift: botR  ;m
  135.  
  136. :m ->:    ^base 8  aligned_move  ;m
  137.  
  138.  
  139. :m DRAW:    ^base  call framerect  ;m
  140. :m DISP:    put: self  draw: self  ;m
  141. :m CLEAR:    ^base  call eraserect  ;m
  142.  
  143. :m FILL:        \ ( ^patobj -- )  Fills rect with pattern
  144.     -> tmpPtn
  145.     get: tmpPtn  ^base  swap  call fillrect   ;m
  146.  
  147. :m DROPSHADOW:  { \ lf top rt bot -- }
  148.     get: topL  -> top  -> lf
  149.     get: botR  -> bot  -> rt
  150.     draw: self
  151.     rt  top 3+  moveto
  152.     0  bot top - 3-  line
  153.     lf rt - 3+  0  line  ;m
  154.  
  155. :m INVERT:    ^base  call inverrect  ;m
  156.  
  157. :m PAINT:    ^base  call paintrect  ;m
  158.  
  159. :m CLIP:        \ Clips drawing to this rect
  160.     ^base  call clipRect  ;m
  161.  
  162. :m UPDATE:    \ Adds rect to update region
  163.     ^base  call InvalRect  ;m
  164.  
  165. ;class
  166.  
  167. fpRect  ' rect  set_class        \ Make fpRect a rect object
  168.  
  169.  
  170. \ A temporary rectangle, usable by anything
  171.  
  172. rect    TEMPRECT
  173.  
  174.  
  175.  
  176. \ ed-boy 951013 - revised Grafport record
  177.  
  178. :class  GRAFPORT  super{ object }
  179.  
  180. record
  181. {        int        device
  182.         handle    portPixMap
  183.         int        portVersion
  184.         handle    grafVars
  185.         int        chExtra
  186.         int        pnLocHFrac
  187.         rect    portRect
  188.     44    bytes   graf2            \ unmapped
  189.         var        TEXT1           \ font,face,mode,size
  190.         var        TEXT2
  191.     32    bytes    graf3           \ unmapped
  192. }
  193.  
  194. :m SET:         \ Makes this grafport current
  195.         ^base  call setPort  ;m
  196.  
  197. :m GETRECT:     \ ( l t r b -- )  Gets values for portRect
  198.         get: portRect  ;m
  199.  
  200. :m PUTRECT:     \ ( l t r b -- )  Stores values for portRect
  201.         put: portRect  ;m
  202.         
  203. :m GetPortPixMap: portPixMap ;m
  204.  
  205.  
  206. ;class
  207.  
  208.  
  209. : PUSHPORT    0 sp@ call GetPort  ;
  210. : POPPORT    call SetPort  ;
  211.  
  212.  
  213. \        ============= Cursors ==============
  214.  
  215. : CURSOR
  216.     <builds    w,
  217.     does>        0 swap w@ makeint  call GetCursor
  218.                 >ptr  call SetCursor  ;
  219.  
  220. \ predefined cursors
  221.  
  222. 1  cursor    IBEAMCURS
  223. 2  cursor    CROSSCURS
  224. 3  cursor    PLUSCURS
  225. 4  cursor    WATCHCURS
  226.  
  227. : ARROWCURS    call InitCursor  ;
  228.